home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE18 / FONTS / DYNFONT.PAS < prev    next >
Pascal/Delphi Source File  |  1997-01-13  |  3KB  |  108 lines
  1. unit dynfont;
  2.  
  3. interface
  4.  
  5. uses SysUtils;
  6.  
  7. type
  8.   {Create a customised exception for this process}
  9.   EDynFontError = class(Exception);
  10.  
  11. procedure LoadFonts(aFontNames : array of string);
  12. procedure DeleteFonts;
  13.  
  14. implementation
  15.  
  16. uses {$ifdef WIN32}
  17.         windows,
  18.      {$else}
  19.         wintypes, winprocs,
  20.      {$endif}
  21.      messages, classes, forms;
  22.  
  23.  
  24. var
  25.   slFonts : TStringList;
  26.  
  27. {$ifdef WIN32}
  28. { Returns the path to the system's TEMP dir (Win32)}
  29. function strTempPath : string;
  30. var
  31.   strTempPath : string;
  32.   nChars : integer;
  33. begin
  34.   SetLength(strTempPath,255);  // allocate 255 chars in the string
  35.   nChars := GetTempPath(254,PChar(strTempPath)); // get the temp location
  36.   // Check that GetTempPath worked ok
  37.   if (nChars = 0) or (nChars > 254)  then
  38.     raise EDynFontError.Create('Can not get location of TEMP directory');
  39.   result := strTempPath;
  40. end;
  41. {$endif}
  42.  
  43. procedure LoadFont(name : string);
  44. var
  45.   pstrFotFile, pstrTmp, pzttf : array [0..250] of char;
  46.   ttf : string;
  47. begin
  48.   {Create a path to this directory & the font file}
  49.   ttf := ExtractFilePath(Application.ExeName) + name + '.ttf';
  50.   StrPCopy(pzttf,ttf);
  51.   {We want to create the .fot files in the temp dir}
  52.   {$ifdef WIN32}
  53.     GetTempFileName(PChar(strTempPath), PChar(name), 0, pstrFotFile);
  54.   {$else}
  55.     GetTempFileName(GetTempDrive('x'), StrPCopy(pstrTmp,name), 0, pstrFotFile);
  56.   {$endif}
  57.   {Now store the temp file name in the string list so we can delete it later}
  58.   slFonts.Add(StrPas(pstrFotFile));
  59.   {if the fot file exists then delete it}
  60.   SysUtils.DeleteFile(StrPas(pstrFotFile));
  61.   {Create the fot file}
  62.   if not CreateScalableFontResource(1,pstrFotFile,pzttf,nil) then
  63.     raise EDynFontError.Create('Error in CreateScaleableFontResource.'+#10+ttf);
  64.   {Add it to the font table}
  65.   if AddFontResource(pstrFotFile) = 0 then
  66.     raise EDynFontError.Create('Error in AddFontResources ' + name);
  67. end;
  68.  
  69. procedure LoadFonts(aFontNames : array of string);
  70. var
  71.   i : integer;
  72. begin
  73.   {call loadfont for each item in the array}
  74.   for i:=low(aFontNames) to high(aFontNames) do
  75.     LoadFont(aFontNames[i]);
  76.   {Inform the system that the fonts have changed}
  77.   SendMessage($FFFF,WM_FONTCHANGE,0,0);
  78. end;
  79.  
  80. procedure DeleteFonts;
  81. var
  82.   pstrTmp : array [0..150] of char;
  83.   i : integer;
  84. begin
  85.   {iterate through FOT files}
  86.   for i:=0 to slFonts.Count - 1 do
  87.   begin
  88.     {Remove the font from the window's font table then delete the tmp file}
  89.     if not RemoveFontResource(StrPCopy(pstrTmp,slFonts[i])) then
  90.       raise EDynFontError.Create('Error in RemoveFontResource');
  91.     SysUtils.DeleteFile(slFonts[i]);
  92.   end;
  93.   {Inform the system that the fonts have changed}
  94.   SendMessage($FFFF,WM_FONTCHANGE,0,0);
  95.   {$ifndef WIN32}
  96.     {Finished with the string list}
  97.     slFonts.Free;
  98.   {$endif}
  99. end;
  100.  
  101. initialization
  102.   slFonts := TStringList.Create;
  103. {$ifdef WIN32}
  104.   finalization
  105.     slFonts.Free;
  106. {$endif}
  107. end.
  108.